;;; -*- Mode:LISP; Package:(FSI :USE LISP) ; Base:10; Readtable:CL -*-

;;;; Useful subroutines which should live outside this file.

(DEFUN MAKE-SYMBOL-FROM-CONCATENATED-NAMES (&OPTIONAL (PKG *PACKAGE*) &REST FROBS)
  (INTERN (APPLY #'CONCATENATE 'STRING
                 (MAP 'LIST #'STRING-UPCASE FROBS))
          PKG))

;;;; Immediate instances.

(DEFMACRO DEFINSTANCE-IMMEDIATE (NAME &BODY INSTANCE-VARIABLES)
  (LET ((INSTANCE-VARIABLE-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-INSTANCE-VARIABLES"))
        (METHOD-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-WHICH-OPERATIONS")))
    (SET METHOD-LIST-NAME NIL)
    (SET INSTANCE-VARIABLE-LIST-NAME INSTANCE-VARIABLES)
    `(PROGN 'COMPILE
            (SETQ ,INSTANCE-VARIABLE-LIST-NAME ',INSTANCE-VARIABLES)
            (SETQ ,METHOD-LIST-NAME NIL)
            (SETF (GET ',NAME 'SI:FLAVOR) T)    ;This makes M-. work
            (DEFVAR ,NAME))))

(DEFMACRO DECLARE-INSTANCE-IMMEDIATE-INSTANCE-VARIABLES ((NAME) &BODY BODY)
  (LET ((INSTANCE-VARIABLE-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-INSTANCE-VARIABLES")))
    `(LOCAL-DECLARE ((SPECIAL . ,(SYMBOL-VALUE INSTANCE-VARIABLE-LIST-NAME)))
                    . ,BODY)))

(EVAL-WHEN (COMPILE LOAD)
  (SETF (GET 'DECLARE-INSTANCE-IMMEDIATE-INSTANCE-VARIABLES 'SI:MAY-SURROUND-DEFUN) T))


(DEFMACRO DEFMETHOD-IMMEDIATE ((NAME MESSAGE) ARGLIST &BODY BODY)
  (LET ((METHOD-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-WHICH-OPERATIONS"))
        (METHOD-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME #\- MESSAGE "-METHOD")))
    (WHEN (MEMBER MESSAGE (SYMBOL-VALUE METHOD-LIST-NAME))
      (PUSH MESSAGE (SYMBOL-VALUE METHOD-LIST-NAME)))
    `(DECLARE-INSTANCE-IMMEDIATE-INSTANCE-VARIABLES (,NAME)
       (DEFUN ,METHOD-NAME (IGNORE . ,ARGLIST)
         . ,BODY))))

(DEFMACRO MAKE-INSTANCE-IMMEDIATE (NAME INIT-PLIST-GENERATOR)
  (LET ((INSTANCE-VARIABLE-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-INSTANCE-VARIABLES"))
        (METHOD-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-WHICH-OPERATIONS"))
        (SEND-IF-HANDLES-METHOD-NAME
          (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-SEND-IF-HANDLES"))
        (OPERATION-HANDLED-P-METHOD-NAME
          (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-OPERATION-HANDLED-P"))
        (GET-HANDLER-FOR-METHOD-NAME
          (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-GET-HANDLER-FOR"))
        (METHOD-LIST 'SI:UNCLAIMED-MESSAGE))
    (DOLIST (MESSAGE (SYMBOL-VALUE METHOD-LIST-NAME))
      (LET ((METHOD-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME #\- MESSAGE "-METHOD")))
        (PUSH (CONS MESSAGE METHOD-NAME) METHOD-LIST)))
    (PUSH (CONS ':WHICH-OPERATIONS METHOD-LIST-NAME) METHOD-LIST)
    (PUSH (CONS ':SEND-IF-HANDLES SEND-IF-HANDLES-METHOD-NAME) METHOD-LIST)
    (PUSH (CONS ':OPERATION-HANDLED-P OPERATION-HANDLED-P-METHOD-NAME) METHOD-LIST)
    (PUSH (CONS ':GET-HANDLER-FOR GET-HANDLER-FOR-METHOD-NAME) METHOD-LIST)
    `(PROGN 'COMPILE
            (DEFUN ,SEND-IF-HANDLES-METHOD-NAME (IGNORE OPERATION &REST ARGS)
              (IF (MEMBER OPERATION (,METHOD-LIST-NAME NIL))
                  (LEXPR-SEND SELF OPERATION ARGS)))
            (DEFUN ,OPERATION-HANDLED-P-METHOD-NAME (IGNORE OPERATION)
              (MEMBER OPERATION (,METHOD-LIST-NAME NIL)))
            (DEFUN ,GET-HANDLER-FOR-METHOD-NAME (IGNORE OPERATION)
              (IF (MEMBER OPERATION (,METHOD-LIST-NAME NIL))
                  (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL ',NAME "-" OPERATION)
                ',(PKG-NAME PACKAGE)))
            (DEFUN ,METHOD-LIST-NAME (IGNORE)
              ',(SYMBOL-VALUE METHOD-LIST-NAME))
            (SETQ ,NAME (FAKE-UP-INSTANCE ',NAME ',(SYMBOL-VALUE INSTANCE-VARIABLE-LIST-NAME)
                                          ',METHOD-LIST ',INIT-PLIST-GENERATOR)))))
